home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tclX6.4c / dist / tests / testlib.tcl < prev    next >
Encoding:
Text File  |  1992-11-07  |  3.3 KB  |  101 lines
  1. #
  2. # testlib.tcl --
  3. #
  4. # Test support routines.  Some of these are based on routines provided with
  5. # standard Tcl.
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
  8. #
  9. # Permission to use, copy, modify, and distribute this software and its
  10. # documentation for any purpose and without fee is hereby granted, provided
  11. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12. # Mark Diekhans make no representations about the suitability of this
  13. # software for any purpose.  It is provided "as is" without express or
  14. # implied warranty.
  15. #------------------------------------------------------------------------------
  16. # $Id: testlib.tcl,v 2.0 1992/10/16 04:49:22 markd Rel $
  17. #------------------------------------------------------------------------------
  18. #
  19.  
  20.  
  21. rename unknown SAVED_UNKNOWN
  22.  
  23. #
  24. # 
  25. #
  26. proc OutTestError {test_name test_description contents_of_test
  27.                    passing_int_result passing_result int_result result} {
  28.     set int(0) TCL_OK
  29.     set int(1) TCL_ERROR
  30.     set int(2) TCL_RETURN
  31.     set int(3) TCL_BREAK
  32.     set int(4) TCL_CONTINUE
  33.  
  34.     puts stdout "==== $test_name $test_description"
  35.     puts stdout "==== Contents of test case:"
  36.     puts stdout "$contents_of_test"
  37.     puts stdout "==== Result was: $int($int_result)"
  38.     puts stdout "$result"
  39.     puts stdout "---- Result should have been: $int($passing_int_result)"
  40.     puts stdout "$passing_result"
  41.     puts stdout "---- $test_name FAILED" 
  42.  
  43. }
  44.  
  45. proc test {test_name test_description contents_of_test passing_results} {
  46.     set answer [uplevel $contents_of_test]
  47.     if {$answer != $passing_results}  { 
  48.         puts stdout "==== $test_name $test_description"
  49.         puts stdout "==== Contents of test case:"
  50.         puts stdout "$contents_of_test"
  51.         puts stdout "==== Result was:"
  52.         puts stdout "$answer"
  53.     puts stdout "---- Result should have been:"
  54.     puts stdout "$passing_results"
  55.     puts stdout "---- $test_name FAILED" 
  56.     }
  57. }
  58.  
  59. proc Test {test_name test_description contents_of_test passing_int_result
  60.            passing_result} {
  61.     set int_result [catch {uplevel $contents_of_test} result]
  62.  
  63.     if {($int_result != $passing_int_result) ||
  64.         ($result != $passing_result)} {
  65.         OutTestError $test_name $test_description $contents_of_test \
  66.                      $passing_int_result $passing_result $int_result $result
  67.     }
  68. }
  69.  
  70. #
  71. # Compare result against case-insensitive regular expression.
  72. #
  73.  
  74. proc TestReg {test_name test_description contents_of_test passing_int_result
  75.               passing_result} {
  76.     set int_result [catch {uplevel $contents_of_test} result]
  77.  
  78.     if {($int_result != $passing_int_result) ||
  79.         ![regexp -nocase $passing_result $result]} {
  80.         OutTestError $test_name $test_description $contents_of_test \
  81.                      $passing_int_result $passing_result $int_result $result
  82.     }
  83. }
  84.  
  85. proc dotests {file args} {
  86.     global TESTS
  87.     set savedTests $TESTS
  88.     set TESTS $args
  89.     source $file
  90.     set TESTS $savedTests
  91. }
  92.  
  93. # Genenerate a unique file record that can be verified.  The record
  94. # grows quite large to test the dynamic buffering in the file I/O.
  95.  
  96. proc GenRec {id} {
  97.     return [format "Key:%04d {This is a test of file I/O (%d)} KeyX:%04d %s" \
  98.                     $id $id $id [replicate :@@@@@@@@: $id]]
  99. }
  100.  
  101.